home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / threads.c < prev    next >
C/C++ Source or Header  |  1992-10-27  |  28KB  |  1,127 lines
  1. /* ******************************************************************** */
  2. /* threads.c         Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Lightweight processes                                        */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: threads.c,v 1.21 1992/10/26 15:35:26 djb Exp $
  9.  *
  10.  * $Log: threads.c,v $
  11.  * Revision 1.21  1992/10/26  15:35:26  djb
  12.  * DGC changes
  13.  *
  14.  * Revision 1.20  1992/08/06  18:15:32  pab
  15.  * init. method -> function
  16.  *
  17.  * Revision 1.19  1992/06/01  13:48:33  pab
  18.  * clipper better fix
  19.  *
  20.  * Revision 1.18  1992/05/28  11:28:47  pab
  21.  * moved initialisation around for compiler
  22.  *
  23.  * Revision 1.17  1992/04/29  12:35:11  pab
  24.  * clipper hack
  25.  *
  26.  * Revision 1.16  1992/03/13  18:10:07  pab
  27.  * SysV fixes (protection around semaphores)
  28.  *
  29.  * Revision 1.15  1992/02/10  12:02:38  pab
  30.  * Debugger addition, plus sysV fix
  31.  *
  32.  * Revision 1.14  1992/02/03  00:38:43  pab
  33.  * pre sysV hack
  34.  *
  35.  * Revision 1.13  1992/01/29  20:10:43  pab
  36.  * fewer exports in Generic version
  37.  *
  38.  * Revision 1.12  1992/01/29  13:51:00  pab
  39.  * sysV fixes
  40.  *
  41.  * Revision 1.11  1992/01/21  22:23:52  pab
  42.  * fixed call to garbage_collect
  43.  *
  44.  * Revision 1.10  1992/01/15  21:23:52  pab
  45.  * Fixed alignment problems; made threads allocate int arrays
  46.  *
  47.  * Revision 1.9  1992/01/09  22:29:10  pab
  48.  * Fixed for low tag ints
  49.  *
  50.  * Revision 1.8  1992/01/07  22:15:37  pab
  51.  * ncc compatable, plus backtrace
  52.  *
  53.  * Revision 1.7  1992/01/07  16:18:35  pab
  54.  * tidy of continuation fns
  55.  *
  56.  * Revision 1.6  1992/01/05  22:48:30  pab
  57.  * Minor bug fixes, plus BSD version
  58.  *
  59.  * Revision 1.5  1991/12/22  15:14:43  pab
  60.  * Xmas revision
  61.  *
  62.  * Revision 1.4  1991/11/15  13:45:47  pab
  63.  * copyalloc rev 0.01
  64.  *
  65.  * Revision 1.3  1991/09/22  19:14:43  pab
  66.  * Fixed obvious bugs
  67.  *
  68.  * Revision 1.2  1991/09/11  12:07:49  pab
  69.  * 11/9/91 First Alpha release of modified system
  70.  *
  71.  * Revision 1.1  1991/08/12  16:50:09  pab
  72.  * Initial revision
  73.  *
  74.  * Revision 1.11  1991/06/17  19:01:05  pab
  75.  * Adjusted set_assoc
  76.  *
  77.  * Revision 1.10  1991/06/17  18:58:28  kjp
  78.  * just in case
  79.  *
  80.  * Revision 1.9  1991/04/16  17:59:57  kjp
  81.  * Tidy.
  82.  *
  83.  * Revision 1.8  1991/03/01  15:50:12  kjp
  84.  * Fixed any machine version.
  85.  *
  86.  * Revision 1.7  1991/02/28  14:14:48  kjp
  87.  * Lots of good stuff.
  88.  *
  89.  * Revision 1.6  1991/02/13  18:26:27  kjp
  90.  * Pass.
  91.  *
  92.  */
  93.  
  94. #define COBUG(x) /* fprintf(stderr,"COBUG:");x;fflush(stderr) */
  95.  
  96. /*
  97.  * Change Log:
  98.  *   Version 1, April 1990
  99.  */
  100.  
  101. #include "defs.h"
  102. #include "structs.h"
  103. #include "funcalls.h"
  104.  
  105. #include "global.h"
  106. #include "error.h"
  107.  
  108. #include "calls.h"
  109. #include "modboot.h"
  110. #include "symboot.h"
  111.  
  112. #include "allocate.h"
  113. #include "modules.h"
  114. #include "threads.h"
  115. #include "class.h"
  116. #include "vectors.h"
  117. #include "garbage.h"
  118.  
  119. extern void free(void*);
  120. extern LispObject Thread_Class;
  121.  
  122. int command_line_x_debug;
  123.  
  124. /* *************************************************************** */
  125. /* Simple functions for all machines                               */
  126. /* *************************************************************** */
  127.  
  128. EUFUN_1( Fn_threadp, obj)
  129. {
  130.   return((is_thread(obj)?lisptrue:nil));
  131. }
  132. EUFUN_CLOSE
  133.  
  134. EUFUN_0( Fn_current_thread)
  135. {
  136.   return(CURRENT_THREAD());
  137. }
  138. EUFUN_CLOSE
  139.  
  140. EUFUN_1( Fn_continuationp, obj)
  141. {
  142.   return (is_continue(obj) ? lisptrue : nil);
  143. }
  144. EUFUN_CLOSE
  145.  
  146. /* *************************************************************** */
  147. /* When machines can actually do stuff                             */
  148. /* *************************************************************** */
  149.  
  150. #ifndef MACHINE_ANY
  151.  
  152. #define SCHEDBUG(x) /* fprintf(scheduler_debug,"%d:",system_scheduler_number); \
  153.                     x ;fflush(scheduler_debug) ;*/ /*while(getchar()!='\n');*/
  154. #define SDS (scheduler_debug)
  155.  
  156. #define SET_STATE(th) \
  157.   (set_continue(stacktop,((th)->THREAD.state)))
  158.  
  159. #define PROCEED(cont,value) \
  160.   stacktop = load_thread(cont->CONTINUE.thread); \
  161.   call_continue(stacktop,cont,value);
  162.  
  163. #define RUN_THREAD(th) \
  164.   PROCEED(((th->THREAD.state)),th->THREAD.args);
  165.  
  166. #define RUN_DISPATCHER(arg) \
  167.   { \
  168.     LispObject th = SYSTEM_THREAD_SPECIFIC_VALUE(local_dispatcher_thread); \
  169.     PROCEED(((th->THREAD.state)),arg); \
  170.   }
  171.  
  172. #define STACK_FIDDLE (16)
  173.  
  174. #define HOG_THREAD(th)
  175. #define RELEASE_THREAD(th)
  176.  
  177. /* Queue for default scheduling methods... */
  178.  
  179. SYSTEM_GLOBAL(LispObject,list_ready_thread_queue);
  180. SYSTEM_GLOBAL(SystemSemaphore,list_ready_thread_queue_sem);
  181. static SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,local_dispatcher_thread);
  182. static SYSTEM_GLOBAL(LispObject,current_dispatcher_function);
  183. static SYSTEM_GLOBAL(LispObject,list_dispatcher_threads);
  184.  
  185. /* Stack switch user... */
  186.  
  187. static SYSTEM_THREAD_SPECIFIC_DECLARATION(jmp_buf,rig_escape);
  188. static SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,rig_thread);
  189.  
  190. /* REMEMBER: within this function, we're on the thread's stacks!!! */
  191.  
  192. void rig_thread_aux()
  193. {
  194.   LispObject *stacktop;
  195.   LispObject xx;
  196.  
  197.   LispObject thread = SYSTEM_THREAD_SPECIFIC_VALUE(rig_thread);
  198.   extern LispObject Fn_apply(LispObject*);
  199.  
  200.   if (!setjmp(thread->THREAD.state->CONTINUE.machine_state))
  201.     longjmp(SYSTEM_THREAD_SPECIFIC_VALUE(rig_escape),TRUE);
  202.  
  203.   stacktop = thread->THREAD.state->CONTINUE.gc_stack_pointer;
  204.   STACK_TMP(thread);
  205.   EUCALLSET_2(xx,
  206.           Fn_apply,thread->THREAD.fun,thread->THREAD.args);
  207.   UNSTACK_TMP(thread);
  208.   thread->THREAD.value=xx;
  209.   thread->THREAD.status = THREAD_RETURNED;
  210.  
  211.   STACK_TMP(thread);
  212.   SCHEDBUG((fprintf(SDS,"thread returned "),
  213.         EUCALL_2(Fn_print,thread,SchedOut)));
  214.   UNSTACK_TMP(thread);
  215.  
  216.   if (thread->THREAD.parent != nil) {
  217.     stacktop =load_thread(thread->THREAD.parent);
  218.     call_continue(stacktop,
  219.               ((thread->THREAD.parent->THREAD.state)),
  220.           thread->THREAD.value);
  221.   }
  222.  
  223.   RUN_DISPATCHER(thread);
  224. }
  225.   
  226. LispObject system_thread_rig(LispObject *stacktop, LispObject thread)
  227. {
  228.   int start; /* address to set sp register to */
  229.   /* Allocate the stacks */
  230.  
  231.   STACK_TMP(thread);
  232.   thread->THREAD.stack_base
  233.     = (int *) allocate_stack(stacktop,thread->THREAD.stack_size*sizeof(int));
  234.   UNSTACK_TMP(thread);
  235.   STACK_TMP(thread);
  236.   thread->THREAD.gc_stack_base
  237.     = (LispObject *) allocate_stack(stacktop,thread->THREAD.gc_stack_size*sizeof(int));
  238.   UNSTACK_TMP(thread);
  239.   STACK_TMP(thread);
  240.   thread->THREAD.state->CONTINUE.gc_stack_pointer
  241.     = thread->THREAD.gc_stack_base;
  242.  
  243.   if (setjmp(SYSTEM_THREAD_SPECIFIC_VALUE(rig_escape))) return(thread);
  244.   SYSTEM_THREAD_SPECIFIC_VALUE(rig_thread) = thread;
  245.   
  246.   if (thread->THREAD.stack_base==NULL)
  247.     CallError(stacktop,"Rig: Got strange thread\n",thread,NONCONTINUABLE);
  248.  
  249.   /* The ~7 is to align on a nice boundary --- no real point making it a #define */
  250.   start=(int) (thread->THREAD.stack_base
  251.                       + thread->THREAD.stack_size - STACK_FIDDLE)&(~7);
  252. #ifdef STACK_START_MISALIGNED
  253.   start+=4;
  254. #endif
  255.   stack_switch_and_go(start,
  256.               (int) rig_thread_aux);
  257.  
  258.   return(nil);
  259. }
  260.  
  261. /*
  262.  * Free re-usable resources of unrunnable threads... 
  263.  */
  264.  
  265. void shut_down_thread(LispObject *stacktop,LispObject th)
  266. {
  267.   void deallocate_stack(LispObject *, char *, int);
  268.  
  269.   th->THREAD.state->CONTINUE.gc_stack_pointer = NULL;
  270.   STACK_TMP(th);
  271.   deallocate_stack(stacktop,(char *) (th->THREAD.stack_base), 
  272.          th->THREAD.stack_size*sizeof(int));
  273.   deallocate_stack(stacktop,(char *) (th->THREAD.gc_stack_base),
  274.          th->THREAD.gc_stack_size*sizeof(int));
  275.   UNSTACK_TMP(th);
  276.   th->THREAD.stack_base = NULL;
  277.   th->THREAD.gc_stack_base = NULL;
  278.  
  279. /*
  280.   th->THREAD.stack_size = 0;
  281.   th->THREAD.gc_stack_size = 0;
  282. */
  283. }
  284.  
  285. /* Simple thread creation... */
  286.  
  287. #define MIN_THREAD_STACK_SIZE (4*1024)
  288. #define GC_STACK_RATIO        (4)
  289.  
  290. static SYSTEM_GLOBAL(LispObject,default_thread_stack_size);
  291.  
  292. EUFUN_0( Fn_default_thread_stack_size)
  293. {
  294.   return(SYSTEM_GLOBAL_VALUE(default_thread_stack_size));
  295. }
  296. EUFUN_CLOSE
  297.  
  298. EUFUN_1( Fn_default_thread_stack_size_setter, size)
  299. {
  300.   int csize;
  301.  
  302.   if (!is_fixnum(size))
  303.     CallError(stacktop,"(setter default-thread-stack-size): non-integer",
  304.           size,NONCONTINUABLE);
  305.  
  306.   csize = intval(size);
  307.  
  308.   if (csize < MIN_THREAD_STACK_SIZE)
  309.     CallError(stacktop,"(setter default-thread-stack-size): too small",
  310.           size,NONCONTINUABLE);
  311.  
  312.   SYSTEM_GLOBAL_VALUE(default_thread_stack_size) = size;
  313.  
  314.   return(size);
  315. }
  316. EUFUN_CLOSE
  317.   
  318. EUFUN_2(Fn_make_thread, fun, args)
  319. {
  320.   LispObject thread;
  321.  
  322.   if (!is_cons(args)) {
  323.  
  324.     thread 
  325.       = 
  326.     (LispObject) 
  327.       allocate_thread(stacktop,
  328.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  329.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  330.               0);
  331.   }
  332.   else {
  333.     LispObject size;
  334.     int csize;
  335.  
  336.     if (!is_fixnum((size = CAR(args))))
  337.       CallError(stacktop,"make-thread: invalid size",size,NONCONTINUABLE);
  338.  
  339.     csize = intval(size);
  340.  
  341.     if (csize <= 0)
  342.       CallError(stacktop,"make-thread: negative size",size,NONCONTINUABLE);
  343.  
  344.     if (csize < MIN_THREAD_STACK_SIZE)
  345.       CallError(stacktop,
  346.         "make-thread: size less than minimun",size,NONCONTINUABLE);
  347.  
  348.     thread = (LispObject) allocate_thread(stacktop,ALIGN_SIZE(csize),
  349.                       ALIGN_SIZE(csize/GC_STACK_RATIO),0);
  350.   }
  351.  
  352.   fun = ARG_0(stackbase);
  353.   thread->THREAD.fun = fun;
  354.   thread->THREAD.status = THREAD_LIMBO;
  355.  
  356.   return(thread);
  357. }
  358. EUFUN_CLOSE
  359.  
  360. EUFUN_1( Fn_thread_reset, th)
  361. {
  362.   if (!is_thread(th))
  363.     CallError(stacktop,"thread-reset: non thread",th,NONCONTINUABLE);
  364.  
  365.   if (th->THREAD.status != THREAD_RETURNED 
  366.        && th->THREAD.status != THREAD_ABORTED)
  367.     CallError(stacktop,"thread-reset: thread in use",th,NONCONTINUABLE);
  368.  
  369.   (void) system_thread_rig(stacktop,th);
  370.  
  371.   th = ARG_0(stackbase);
  372.   th->THREAD.value = nil;
  373.   th->THREAD.status = THREAD_LIMBO;
  374.  
  375.   return(th);
  376. }
  377. EUFUN_CLOSE
  378.  
  379. LispObject generic_thread_call;
  380.  
  381. EUFUN_2(Fn_thread_call, thread, args)
  382. {
  383.   LispObject me;
  384.  
  385.   if (!is_thread(thread))
  386.     CallError(stacktop,"thread-call: non-thread",thread,NONCONTINUABLE);
  387.  
  388.   if (thread->THREAD.status != THREAD_LIMBO)
  389.     CallError(stacktop,
  390.           "thread-call: thread not in limbo",thread,NONCONTINUABLE);
  391.  
  392.   /* Liberate the thread... */
  393.  
  394.   HOG_THREAD(thread);
  395.  
  396.   thread->THREAD.status = THREAD_RUNNING;
  397.   thread->THREAD.args = args;
  398.   me = CURRENT_THREAD();
  399.  
  400.   SCHEDBUG((fprintf(SDS,"Thread call from "), 
  401.         EUCALL_2(Fn_prin,me,SchedOut), 
  402.         fprintf(SDS," to "), 
  403.         EUCALL_2(Fn_print,th,SchedOut)));
  404.  
  405.   thread->THREAD.parent = me;
  406.  
  407.   RELEASE_THREAD(thread);
  408.  
  409.   if (SET_STATE(me)) {
  410.  
  411.     /* On caller... */
  412.  
  413.     SCHEDBUG((fprintf(SDS,"thread call returned to "),
  414.           EUCALL_2(Fn_print,me,SchedOut)));
  415.     
  416.     thread=ARG_0(stackbase);
  417.     thread->THREAD.parent = nil;
  418.     shut_down_thread(stacktop,thread);
  419.  
  420.     return(thread->THREAD.value);
  421.   }
  422.  
  423.   RUN_THREAD(thread);
  424.  
  425.   return(nil); /* Shouldn't get here */
  426. }
  427. EUFUN_CLOSE
  428.  
  429. /* Run on the dispatcher thread... */
  430.  
  431. EUFUN_1( Fn_next_ready_thread, c)
  432. {
  433.   LispObject thread;
  434.  
  435.   /* Peek... */
  436.  
  437.   if (SYSTEM_GLOBAL_VALUE(list_ready_thread_queue) == nil) return(nil);
  438.  
  439.   /* For real... */
  440.  
  441.   system_open_semaphore(stacktop,
  442.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  443.   if (SYSTEM_GLOBAL_VALUE(list_ready_thread_queue) == nil) {
  444.     system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  445.     return(nil);
  446.   }
  447.  
  448.   thread = CAR(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  449.   SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)
  450.     = CDR(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  451.  
  452.   system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  453.  
  454.   return(thread);
  455. }
  456. EUFUN_CLOSE
  457.  
  458. EUFUN_1( Fn_run_ready_thread, th)
  459. {
  460.  
  461. /*
  462.   #ifdef MACHINE_SYSTEMV
  463.   fprintf(stderr,"{R(%x):%x}",system_scheduler_number,(int) th);
  464.   fflush(stderr);
  465.   #endif
  466. */
  467.  
  468.   while (th->THREAD.status != THREAD_READY); /* Hedge */
  469.  
  470.   if (SET_STATE(CURRENT_THREAD())) {
  471.     th=ARG_0(stackbase);
  472.     return(th);
  473.   }
  474.   th=ARG_0(stackbase);
  475.   /* Have we done the stack business yet? */
  476.  
  477.   if (th->THREAD.stack_base == NULL) {
  478.     system_thread_rig(stacktop,th);
  479.     th = ARG_0(stackbase);
  480.   }
  481.  
  482.   th->THREAD.status = THREAD_RUNNING;
  483.  
  484.   RUN_THREAD(th);
  485.  
  486.   return(nil); /* Dummy */
  487. }
  488. EUFUN_CLOSE
  489.   
  490. #define SCHEDULER_RETRY_COUNT (1024) /* was 48*1024*/
  491.  
  492. EUFUN_0( Fn_dispatch)
  493. {
  494.   LispObject from = nil;
  495.   int tries = 0;
  496.  
  497.  restart:
  498.  
  499.   /*
  500.   if (SET_STATE(CURRENT_THREAD())) {
  501.     from = CURRENT_THREAD()->THREAD.state->CONTINUE.value;
  502.     goto restart;
  503.   }
  504.   */
  505.  
  506.   if (is_thread(from)) {
  507.  
  508.     switch (from->THREAD.status) {
  509.  
  510.      case THREAD_RETURNED:
  511.      case THREAD_ABORTED:
  512.  
  513.       (void) shut_down_thread(stacktop,from);
  514.       break;
  515.  
  516.      case THREAD_READY:
  517.  
  518.       {
  519.     LispObject cell = nil;
  520.     STACK_TMP(from); 
  521.     if (from->THREAD.cochain==nil)
  522.       {
  523.         LispObject xx;
  524.         xx=EUCALL_2(Fn_cons,nil,nil);
  525.         UNSTACK_TMP(from);
  526.         STACK_TMP(from);
  527.         from->THREAD.cochain=xx;
  528.         fprintf(stderr,"{}");
  529.       }
  530.     system_open_semaphore(stacktop,
  531.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  532.     UNSTACK_TMP(from);
  533.     cell=from->THREAD.cochain;
  534.         
  535.     CAR(cell)=from;
  536.     CDR(cell)=nil;
  537.     EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  538.             Fn_nconc,
  539.             SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),cell);
  540.     system_close_semaphore(
  541.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  542.     
  543.     break;
  544.       }
  545.  
  546.      default:
  547.  
  548.       break;
  549.     }
  550.  
  551.   }
  552.  
  553.   SCHEDBUG(printf("Setting dispatch state...\n"); fflush(stdout));
  554.  
  555.   SCHEDBUG(printf("Dispatching...\n"); fflush(stdout));
  556.  
  557.   tries = 0;
  558.   while (TRUE) {
  559.  
  560.     while (tries < SCHEDULER_RETRY_COUNT) {
  561.       LispObject thread;
  562.  
  563.       EUCALLSET_1(thread, Fn_next_ready_thread, Thread);
  564.       if (is_thread(thread)) {
  565.     EUCALLSET_1(from, Fn_run_ready_thread, thread);
  566.     STACK_TMP(from);
  567.     GC_sync_test();
  568.     UNSTACK_TMP(from);
  569.     goto restart;
  570.       }
  571.  
  572.       GC_sync_test();
  573.  
  574.       ++tries;
  575.     }
  576.  
  577.     system_sleep_until_kicked();
  578.  
  579.     GC_sync_test();
  580.  
  581.     tries = 0;
  582.   }
  583.  
  584.   return(nil);
  585. }
  586. EUFUN_CLOSE
  587.   
  588. EUFUN_2(Fn_thread_start, thread, args)
  589. {
  590.   COBUG(fprintf(stderr,"In thread-start\n"));
  591.  
  592.   if (!is_thread(thread))
  593.     CallError(stacktop,
  594.           "thread-start: non-thread argument",thread,NONCONTINUABLE);
  595.  
  596.   if (thread->THREAD.status != THREAD_LIMBO)
  597.     CallError(stacktop,
  598.           "thread-start: thread not in limbo",thread,NONCONTINUABLE);
  599.  
  600.   HOG_THREAD(thread);
  601.  
  602.   /* Place the args inside and wind her up... */
  603.  
  604.   thread->THREAD.status = THREAD_READY;
  605.   thread->THREAD.args = args;
  606.  
  607.   RELEASE_THREAD(thread);
  608.  
  609.   /* Bung it on the ready queue... */
  610.  
  611.   STACK_TMP(thread);
  612.   system_open_semaphore(stacktop,&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  613.   UNSTACK_TMP(thread);
  614.   {
  615.     LispObject xx;
  616.     STACK_TMP(thread);
  617.     EUCALLSET_2(xx,Fn_cons,thread,nil);
  618.     
  619.     thread->THREAD.cochain=xx;
  620. /**    EUCALLSET_2(xx, Fn_cons,thread,nil);**/
  621.     CAR(thread->THREAD.cochain)=thread;
  622.     CDR(thread->THREAD.cochain)=nil;
  623.     EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  624.         Fn_nconc, SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  625.         thread->THREAD.cochain);
  626.   }
  627.   system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  628.  
  629.   /* All is cool... */
  630.  
  631.   /* Poke layabouts... */
  632.  
  633.   system_kick_sleepers();
  634.  
  635.   return(ARG_0(stackbase));
  636. }
  637. EUFUN_CLOSE
  638.  
  639. EUFUN_0( Fn_thread_reschedule)
  640. {
  641.   LispObject thread = CURRENT_THREAD();
  642.  
  643. #ifdef DGC
  644.   /* Tidy the stacks ... */
  645.   void tidy_stacks(LispObject *);
  646.   tidy_stacks(stacktop);
  647. #endif
  648.  
  649.   HOG_THREAD(thread);
  650.   if (SET_STATE(thread)) return(nil);
  651.   RELEASE_THREAD(thread);
  652.  
  653. #ifdef nope /* Mon Mar  2 12:54:29 1992 */
  654. /**/  /* following lines commented out --- probably wrong */
  655. /**/  system_open_semaphore(stacktop,&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  656. /**/  SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)
  657. /**/  = EUCALL_2(Fn_nconc,SYSTEM_GLOBAL_VALUE(list_ready_thread_queue), Fn_cons(thread,nil));
  658. /**/  system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  659. /**/  /**/
  660. #endif /* nope Mon Mar  2 12:54:29 1992 */
  661.  
  662.   /* Call the dispatcher... */
  663.  
  664.   thread->THREAD.status = THREAD_READY;
  665.   RUN_DISPATCHER(thread);
  666.  
  667.   return(nil);
  668. }
  669. EUFUN_CLOSE
  670.  
  671. EUFUN_0( Fn_thread_suspend)
  672. {
  673.   LispObject thread = CURRENT_THREAD();
  674.  
  675. #ifdef DGC
  676.   /* Tidy the stacks ... */
  677.   void tidy_stacks(LispObject *);
  678.   tidy_stacks(stacktop);
  679. #endif
  680.  
  681.   /* Must be running */
  682.   STACK_TMP(thread);
  683.  
  684.   if (SET_STATE(thread))
  685.     {    
  686.       thread=ARG_0(stackbase);
  687.       return(thread->THREAD.args);
  688.     }
  689.  
  690.   thread->THREAD.status = THREAD_LIMBO;
  691.  
  692.   RUN_DISPATCHER(nil);
  693.  
  694.   return(nil);
  695. }
  696. EUFUN_CLOSE
  697.  
  698. EUFUN_0( Fn_abort_thread)
  699. {
  700.   LispObject thread = CURRENT_THREAD();
  701.  
  702. #ifdef DGC
  703.   /* Tidy the stacks ... */
  704.   void tidy_stacks(LispObject *);
  705.   tidy_stacks(stacktop);
  706. #endif
  707.  
  708.   HOG_THREAD(thread);
  709.   thread->THREAD.status = THREAD_ABORTED;
  710.   RELEASE_THREAD(thread);
  711.  
  712.   RUN_DISPATCHER(nil);
  713.  
  714.   return(nil);
  715. }
  716. EUFUN_CLOSE
  717.  
  718. EUFUN_1( Fn_thread_value, thread)
  719. {
  720.   if (!is_thread(thread))
  721.     CallError(stacktop,"thread-value: non-thread",thread,NONCONTINUABLE);
  722.  
  723.  switchstart:
  724.   thread=ARG_0(stackbase);
  725.   switch (thread->THREAD.status) {
  726.  
  727.    case THREAD_RETURNED:  return(thread->THREAD.value);
  728.  
  729.    case THREAD_LIMBO:
  730.    case THREAD_RUNNING:
  731.    case THREAD_READY: 
  732.     {
  733.       EUCALL_0(Fn_thread_reschedule);
  734.       goto switchstart;
  735.     }
  736.  
  737.    case THREAD_ABORTED: 
  738.      CallError(stacktop,
  739.            "thread_value: thread aborted",thread,NONCONTINUABLE);
  740.  
  741.    default: CallError(stacktop,
  742.               "thread-value: bad thread status",thread,NONCONTINUABLE);
  743.   }
  744.  
  745.   return(nil);
  746. }
  747. EUFUN_CLOSE
  748.  
  749. static LispObject sym_limbo;
  750. static LispObject sym_ready;
  751. static LispObject sym_running;
  752. static LispObject sym_returned;
  753. static LispObject sym_aborted;
  754.  
  755. EUFUN_1( Fn_thread_state, th)
  756. {
  757.   if (!is_thread(th))
  758.     CallError(stacktop,"thread-state: non-thread",th,NONCONTINUABLE);
  759.  
  760.   switch (th->THREAD.status) {
  761.  
  762.    case THREAD_LIMBO:    return(sym_limbo);
  763.    case THREAD_READY:    return(sym_ready);
  764.    case THREAD_RUNNING:  return(sym_running);
  765.    case THREAD_RETURNED: return(sym_returned);
  766.    case THREAD_ABORTED:  return(sym_aborted);
  767.  
  768.    default: CallError(stacktop,"thread-state: weird state",th,NONCONTINUABLE);
  769.  
  770.   }
  771.  
  772.   return(nil); /* Dummy */
  773. }
  774. EUFUN_CLOSE
  775.  
  776. EUFUN_0( Fn_thread_queue)
  777. {
  778.   return(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  779. }
  780. EUFUN_CLOSE
  781.  
  782. EUFUN_0( Fn_kick)
  783. {
  784.   system_kick_sleepers();
  785.   return(nil);
  786. }
  787. EUFUN_CLOSE
  788.  
  789. /* *************************************************************** */
  790. /*                        Allocation Methods                       */
  791. /* *************************************************************** */
  792.  
  793. static LispObject sym_stack_size;
  794.  
  795. EUFUN_2( Md_allocate_instance_Thread_Class, c, il)
  796. {
  797.   extern LispObject search_keylist(LispObject*,LispObject,LispObject);
  798.   LispObject new,size;
  799.   int i;
  800.  
  801.   if ((size = search_keylist(stacktop,il,sym_stack_size)) == unbound)
  802.     size = SYSTEM_GLOBAL_VALUE(default_thread_stack_size);
  803.   else {
  804.     
  805.     if (!is_fixnum(size))
  806.       CallError(stacktop,"allocate-instance(thread): non-integer stack size",
  807.         size,NONCONTINUABLE);
  808.  
  809.     if (intval(size) < MIN_THREAD_STACK_SIZE)
  810.       CallError(stacktop,"allocate-instance(thread): stack size too small",
  811.         size,NONCONTINUABLE);
  812.  
  813.   }
  814.  
  815.   new = 
  816.     (LispObject) 
  817.       allocate_thread(stacktop,
  818.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  819.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size))
  820.                  / GC_STACK_RATIO,
  821.               c->CLASS.local_count);
  822.  
  823.   lval_classof(new) = ARG_0(stackbase);
  824.  
  825.   return(new);
  826. }
  827. EUFUN_CLOSE
  828.  
  829. EUFUN_2( Fn_initialize_thread, t, il)
  830. {
  831.   extern LispObject Md_initialize_instance_1(LispObject*);
  832.   extern LispObject search_keylist(LispObject*,LispObject,LispObject);
  833.   LispObject fun;
  834.  
  835.   if ((fun = search_keylist(stacktop,il,sym_function)) == unbound)
  836.     CallError(stacktop,"allocate-instance(thread): missing function value",
  837.           il,NONCONTINUABLE);
  838.  
  839.   t->THREAD.fun = fun;
  840.   t->THREAD.status = THREAD_LIMBO;
  841. }
  842. EUFUN_CLOSE
  843.  
  844. #endif
  845.  
  846. /* *************************************************************** */
  847. /*                          Output Methods                         */
  848. /* *************************************************************** */
  849.  
  850. extern LispObject Gf_generic_prin(LispObject*);
  851. extern LispObject generic_generic_prin;
  852. extern LispObject generic_generic_write;
  853.  
  854. EUFUN_2( Md_generic_prin_Thread, t, str)
  855. {
  856.   if (!is_stream(str))
  857.     CallError(stacktop,"generic-prin: not a stream",str,NONCONTINUABLE);
  858.  
  859.   fprintf(str->STREAM.handle,"#<");
  860.   EUCALL_2(Gf_generic_prin,classof(t)->CLASS.name,str);
  861.   t = ARG_0(stackbase);
  862.   str = ARG_1(stackbase);
  863.   fprintf(str->STREAM.handle,": %x %x ",(int) t,t->THREAD.status);
  864.   EUCALL_2(Gf_generic_prin,t->THREAD.value,str);
  865.   fprintf(ARG_1(stackbase)->STREAM.handle,">");
  866.  
  867.   return(ARG_0(stackbase));
  868. }
  869. EUFUN_CLOSE
  870.  
  871. /* *************************************************************** */
  872. /* Test'n'debug                                                    */
  873. /* *************************************************************** */
  874.  
  875. #ifndef MACHINE_ANY
  876.  
  877. LispObject test_reschedule_runner(LispObject* stacktop)
  878. {
  879.   while (TRUE) (void) EUCALL_0(Fn_thread_reschedule);
  880.  
  881.   return(nil);
  882. }
  883.  
  884. EUFUN_1( Fn_test_reschedule, n)
  885. {
  886.   int cn;
  887.  
  888.   cn = intval(n);
  889.  
  890.   while (cn--) {
  891.     LispObject th;
  892.  
  893.     th = allocate_module_function(stacktop, NULL, NULL,
  894.                   test_reschedule_runner,0);
  895.     EUCALLSET_2(th, Fn_make_thread, th, nil);
  896.  
  897.     printf("Test: %x\n",(int) th); fflush(stdout);
  898.  
  899.     EUCALL_2(Fn_thread_start,th,nil);
  900.   }
  901.  
  902.   EUCALL_0(Fn_thread_suspend);
  903.  
  904.   return(nil);
  905. }
  906. EUFUN_CLOSE
  907.  
  908. EUFUN_0( Fn_test_gc)
  909. {
  910.   
  911.   while (1) garbage_collect(stacktop);
  912.  
  913.   return(nil);
  914. }
  915. EUFUN_CLOSE
  916.  
  917. #endif
  918.  
  919. /* so we know who we are... Note that this is an expensive function to call*/
  920. EUFUN_0(Fn_feel_arch)
  921. {
  922. #ifdef MACHINE_ANY
  923.   return(get_symbol(stacktop,"generic"));
  924. #elif defined(MACHINE_BSD)
  925.   return(get_symbol(stacktop,"BSD"));
  926. #endif
  927. #ifdef MACHINE_SYSTEMV
  928.   return(get_symbol(stacktop,"System-V"));
  929. #endif
  930.   /* NOTREACHED*/
  931.   return(get_symbol(stacktop,"something-strange"));
  932. }
  933. EUFUN_CLOSE
  934. /* *************************************************************** */
  935. /* Initialisation of this section                                  */
  936. /* *************************************************************** */
  937.  
  938. #ifdef MACHINE_ANY
  939. #define THREADS_ENTRIES 7
  940. #else
  941. #define THREADS_ENTRIES 25
  942. #endif
  943.  
  944. #define SET_ASSOC(a,b) \
  945.   { LispObject tmp,tmp2; \
  946.     STACK_TMP(a); \
  947.     tmp2=b; \
  948.     UNSTACK_TMP(tmp); \
  949.     set_anon_associate(stacktop,tmp,tmp2); \
  950.   }
  951.  
  952. MODULE Module_threads;
  953. LispObject Module_threads_values[THREADS_ENTRIES];
  954.  
  955. void initialise_threads(LispObject *stacktop)
  956. {
  957.   open_module(stacktop,
  958.           &Module_threads,Module_threads_values,"threads",THREADS_ENTRIES);
  959.  
  960.   (void) make_module_function(stacktop,"threadp",Fn_threadp,1);
  961.   (void) make_module_function(stacktop,"current-thread",Fn_current_thread,0);
  962.   (void) make_module_function(stacktop,"continuationp",Fn_continuationp,1);
  963.  
  964.   (void) make_module_function(stacktop,"generic_generic_prin,Thread,Object",
  965.                   Md_generic_prin_Thread,2
  966.                   );
  967.   (void) make_module_function(stacktop,"generic_generic_write,Thread,Object",
  968.                   Md_generic_prin_Thread,2
  969.                   );
  970.  
  971.   (void) make_module_function(stacktop,"feel-machine-type",Fn_feel_arch,0);
  972.  
  973. #ifdef MACHINE_ANY
  974.   (void) make_module_entry(stacktop,"*threads-available*",nil);
  975. #else
  976.   (void) make_module_entry(stacktop,"*threads-available*",lisptrue);
  977. #endif
  978.  
  979. #ifndef MACHINE_ANY
  980.  
  981.   sym_stack_size = get_symbol(stacktop,"stack-size");
  982.   add_root(&sym_stack_size);
  983.   sym_limbo = get_symbol(stacktop,"limbo");
  984.   add_root(&sym_limbo);
  985.   sym_ready = get_symbol(stacktop,"ready");
  986.   add_root(&sym_ready);
  987.   sym_running = get_symbol(stacktop,"running");
  988.   add_root(&sym_running);
  989.   sym_returned = get_symbol(stacktop,"returned");
  990.   add_root(&sym_returned);
  991.   sym_aborted = get_symbol(stacktop,"aborted");
  992.   add_root(&sym_aborted);
  993.  
  994.   SYSTEM_INITIALISE_GLOBAL(LispObject,
  995.                default_thread_stack_size,
  996.                allocate_integer(stacktop,MY_THREAD_STACK_SIZE));
  997.   ADD_SYSTEM_GLOBAL_ROOT(default_thread_stack_size);
  998.  
  999.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_ready_thread_queue,nil);
  1000.   ADD_SYSTEM_GLOBAL_ROOT(list_ready_thread_queue); 
  1001.  
  1002.   SYSTEM_INITIALISE_GLOBAL(LispObject,current_dispatcher_function,nil);
  1003.   ADD_SYSTEM_GLOBAL_ROOT(current_dispatcher_function);
  1004.  
  1005.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_dispatcher_threads,nil);
  1006.   ADD_SYSTEM_GLOBAL_ROOT(list_dispatcher_threads);
  1007.  
  1008.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,list_ready_thread_queue_sem,NULL);
  1009.   system_allocate_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  1010.  
  1011.   (void) make_module_function(stacktop,"make-thread",Fn_make_thread,-2);
  1012.   (void) make_module_function(stacktop,"thread-start",Fn_thread_start,-2);
  1013.   (void) make_module_function(stacktop,"thread-reschedule",Fn_thread_reschedule,0);
  1014.  
  1015.   (void) make_module_function(stacktop,"thread-call",Fn_thread_call,-2);
  1016.   (void) make_module_function(stacktop,"thread-value",Fn_thread_value,1);
  1017.   (void) make_module_function(stacktop,"thread-suspend",Fn_thread_suspend,0);
  1018.   (void) make_module_function(stacktop,"generic_allocate_instance,Thread_Class",
  1019.                   Md_allocate_instance_Thread_Class,2);
  1020.   (void) make_module_function(stacktop,"initialize-thread", Fn_initialize_thread,2);
  1021.  
  1022.   SYSTEM_GLOBAL_VALUE(current_dispatcher_function)
  1023.     = make_unexported_module_function(stacktop,"dispatcher",Fn_dispatch,0);
  1024.  
  1025.   (void) make_module_function(stacktop,"kick",Fn_kick,0);
  1026.  
  1027.   (void) make_module_function(stacktop,"not-thread-reset",Fn_thread_reset,1);
  1028.  
  1029.   (void) make_module_entry(stacktop,"*minimum-stack-size*",
  1030.                allocate_integer(stacktop,MIN_THREAD_STACK_SIZE));
  1031.  
  1032.   (void) make_module_function(stacktop,"thread-state",Fn_thread_state,1);
  1033.   (void) make_module_function(stacktop,"thread-queue",Fn_thread_queue,0);
  1034.  
  1035.   SET_ASSOC(make_module_function(stacktop,"default-thread-stack-size",
  1036.                  Fn_default_thread_stack_size,
  1037.                  0),
  1038.         make_module_function(stacktop,"(setter default-thread-stack-size)",
  1039.                  Fn_default_thread_stack_size_setter,
  1040.                  1));
  1041.        
  1042.   (void) make_module_function(stacktop,"test-reschedule",Fn_test_reschedule,1);
  1043.  
  1044.   (void) make_module_function(stacktop,"test-gc",Fn_test_gc,0);
  1045.  
  1046. #endif
  1047.  
  1048.   close_module();
  1049.  
  1050. }
  1051.  
  1052. #ifndef MACHINE_ANY
  1053.  
  1054. static SYSTEM_GLOBAL(int,start_register);
  1055.  
  1056. #define DISPATCHER_THREAD_STACK_SIZE (4*1048) /* Woz 4 */
  1057. #define DISPATCHER_THREAD_GC_STACK_SIZE (1024)
  1058.  
  1059. void runtime_begin_processes(LispObject* stacktop)
  1060. {
  1061.   extern void rig_gc_thread(LispObject *);
  1062.   extern int command_line_processors;
  1063.   int i;
  1064.  
  1065.   RUNNING_PROCESSORS() 
  1066.     = (command_line_processors == 0 ? 1 : command_line_processors);
  1067.  
  1068.   rig_gc_thread(stacktop);
  1069.  
  1070.   SYSTEM_INITIALISE_GLOBAL(int,start_register,0);
  1071.  
  1072.   for (i=0; i<RUNNING_PROCESSORS(); ++i) {
  1073.     int val;
  1074.     LispObject new_dt;
  1075.  
  1076.     /* Create and register dispatcher thread for each new process... */
  1077.  
  1078.     new_dt = allocate_thread(stacktop,
  1079.                  DISPATCHER_THREAD_STACK_SIZE,
  1080.                  DISPATCHER_THREAD_GC_STACK_SIZE,0);
  1081.  
  1082.     new_dt->THREAD.fun = SYSTEM_GLOBAL_VALUE(current_dispatcher_function);
  1083.  
  1084.     (void) system_thread_rig(stacktop,new_dt);
  1085.  
  1086.     EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_dispatcher_threads),
  1087.         Fn_cons,new_dt,SYSTEM_GLOBAL_VALUE(list_dispatcher_threads));
  1088.  
  1089.     val = (i == 0 ? 0 : fork());
  1090.  
  1091.     if (val == -1) {
  1092.       fprintf(stderr,"\nRats: fork wimped out\n\n"); fflush(stderr);
  1093.       system_lisp_exit(-1);
  1094.     }
  1095.     if (val == 0) { /* New! */
  1096.       SYSTEM_THREAD_SPECIFIC_VALUE(local_dispatcher_thread) = new_dt;
  1097.       add_root(&local_dispatcher_thread);
  1098. #ifndef NODEBUG
  1099. /*      startdb();*/
  1100. #endif
  1101.       if (i != 0) {
  1102.     runtime_reset_allocator(stacktop);
  1103.  
  1104.     break;
  1105.       }
  1106.  
  1107.     }
  1108.  
  1109.     ++SYSTEM_GLOBAL_VALUE(start_register);
  1110.  
  1111.   }
  1112.  
  1113.   system_register_process(i-1);
  1114.   SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number) = i-1;
  1115.  
  1116.   /* Wait for it... wait for it... */
  1117.  
  1118.   while (SYSTEM_GLOBAL_VALUE(start_register) != RUNNING_PROCESSORS());
  1119.   
  1120.   ON_collect();
  1121.  
  1122.   RUN_DISPATCHER(nil);
  1123. }
  1124.  
  1125. #endif
  1126.  
  1127.